home *** CD-ROM | disk | FTP | other *** search
/ MacGames Sampler / PHT MacGames Bundle.iso / MacSource Folder / Samples from the CD / Editors / emacs / Emacs-1.14b1 / lisp / mac / modifiers.el < prev    next >
Encoding:
Text File  |  1994-03-08  |  6.5 KB  |  188 lines  |  [TEXT/EMAC]
  1. ;;;
  2. ;;; This file is part of a Macintosh port of GNU Emacs.
  3. ;;; Copyright (C) 1993, 1994 Marc Parmet.  All rights reserved.
  4. ;;;
  5. ;;; GNU Emacs is distributed in the hope that it will be useful,
  6. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  7. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  8. ;;; GNU General Public License for more details.
  9. ;;;
  10.  
  11. (defconst metaKey 1)
  12.  
  13. (defconst modifiers:ok-button 1)
  14. (defconst modifiers:cancel-button 2)
  15. (defconst modifiers:revert-button 3)
  16. (defconst modifiers:default-button 4)
  17. (defconst modifiers:simple-meta-button 5)
  18. (defconst modifiers:first-check-box 6)
  19.  
  20. ;;; This list is in the order the items appear in the dialog.
  21. (defvar modifiers:key-sets
  22.   (list
  23.    ;;; format is (index denoted typed-default typed-oam offset-in-pref)
  24.    (list 0 shiftKey shiftKey shiftKey 0)
  25.    (list 1 controlKey controlKey controlKey 4)
  26.    (list 2 alphaLock alphaLock alphaLock 8)
  27.    (list 3 cmdKey cmdKey cmdKey 12)
  28.    (list 4 optionKey optionKey (+ optionKey cmdKey) 16)
  29.    (list 5 (+ controlKey shiftKey) (+ controlKey shiftKey) (+ controlKey shiftKey) 44)
  30.    (list 6 (+ controlKey optionKey) (+ controlKey optionKey) (+ controlKey optionKey cmdKey) 48)
  31.    (list 7 (+ shiftKey optionKey) (+ shiftKey optionKey) (+ shiftKey optionKey cmdKey) 20)
  32.    (list 8 (+ controlKey shiftKey optionKey) (+ controlKey shiftKey optionKey) (+ controlKey shiftKey optionKey cmdKey) 52)
  33.    (list 9 (+ alphaLock optionKey) (+ alphaLock optionKey) (+ alphaLock optionKey cmdKey) 24)
  34.    (list 10 (+ cmdKey optionKey) (+ cmdKey optionKey) (+ alphaLock cmdKey optionKey controlKey) 28)
  35.    (list 11 metaKey 0 optionKey 32)
  36.    (list 12 (+ shiftKey metaKey) 0 (+ shiftKey optionKey) 36)
  37.    (list 13 (+ controlKey metaKey) 0 (+ controlKey optionKey) 40)))
  38.  
  39. (defun modifiers:use-defaults-or-oam (oam)
  40.   (let* ((x (mapcar (function (lambda (x) (list (nth (if oam 3 2) x) (nth 1 x))))
  41.                     modifiers:key-sets))
  42.          (y (apply (function vector) (apply (function append) x))))
  43.     (setq modifier-vector y)))
  44.  
  45. (defun modifiers:use-defaults () (modifiers:use-defaults-or-oam nil))
  46. (defun modifiers:use-option-as-meta () (modifiers:use-defaults-or-oam t))
  47.  
  48. (defun modifiers:set-vector-from-dialog ()
  49.   (setq modifier-vector
  50.         (apply (function vector)
  51.                (apply (function append)
  52.                       (nmapcar
  53.                        (function (lambda (var-name ch-list)
  54.                                    (list (apply (function +)
  55.                                                 (nmapcar
  56.                                                  (function (lambda (ch mask) (* (GetCtlValue ch) mask)))
  57.                                                  ch-list
  58.                                                  (list shiftKey controlKey alphaLock cmdKey optionKey)))
  59.                                          (nth 1 var-name))))
  60.                        modifiers:key-sets
  61.                        chandles))))
  62.   (let ((h (NewHandle (* 4 (length modifiers:key-sets)))))
  63.     (if (zerop (MemError))
  64.         (progn
  65.           (HLock h)
  66.           (mapcar (function (lambda (var)
  67.                                (encode-internal (deref h) (nth 4 var) 'long
  68.                                                 (aref modifier-vector (* 2 (nth 0 var))))))
  69.                   modifiers:key-sets)
  70.           (HUnlock h)
  71.           (set-preference "DATA" 132 h)))))
  72.  
  73. (defun modifiers:initialize ()
  74.   (modifiers:use-defaults)
  75.   (let ((pref (get-preference "DATA" 132)))
  76.     (if (>= pref 0)
  77.         (progn
  78.           (HLock pref)
  79.           (mapcar (function
  80.                    (lambda (var)
  81.                      (let ((offset (nth 4 var)))
  82.                        (aset modifier-vector (* 2 (nth 0 var))
  83.                              (if (< offset (GetHandleSize pref))
  84.                                  (prog2
  85.                                   (HLock pref)
  86.                                   (extract-internal (deref pref) offset 'long)
  87.                                   (HUnlock pref))
  88.                                0)))))
  89.                   modifiers:key-sets)
  90.           (DisposHandle pref)))))
  91.  
  92. (defun modifiers:set-defaults ()
  93.   (modifiers:set-boxes (mapcar (function (lambda (x) (nth 2 x))) modifiers:key-sets)))
  94.  
  95. (defun modifiers:set-simple-meta ()
  96.   (modifiers:set-boxes (mapcar (function (lambda (x) (nth 3 x))) modifiers:key-sets)))
  97.  
  98. (defun modifiers:revert ()
  99.   (modifiers:set-boxes (mapcar
  100.                         (function (lambda (x) (aref modifier-vector (* 2 (nth 0 x)))))
  101.                         modifiers:key-sets)))
  102.  
  103. (defun modifiers:set-boxes (masks)
  104.   (nmapcar
  105.    (function (lambda (ch-list mask)
  106.                (nmapcar
  107.                 (function (lambda (h x) (SetCtlValue h (if (zerop (logand mask x)) 0 1))))
  108.                 ch-list (list shiftKey controlKey alphaLock cmdKey optionKey))))
  109.    chandles masks))
  110.  
  111. (defun modifiers:extract-chandles ()
  112.   (let ((a modifiers:key-sets)
  113.         (type (make-string (c:sizeof 'short) 0))
  114.         (h (make-string (c:sizeof 'Handle) 0))
  115.         (i modifiers:first-check-box))
  116.     (setq chandles nil)
  117.     (while a
  118.       (setq chandles (cons (mapcar (function (lambda (k)
  119.                                                (GetDItem d (+ i k) type h box)
  120.                                                (extract-internal h 0 'unsigned-long)))
  121.                                    '(0 1 2 3 4))
  122.                            chandles))
  123.       (setq a (cdr a))
  124.       (setq i (+ i 5))))
  125.   (setq chandles (nreverse chandles)))
  126.  
  127. (defun do-modifiers (menu item)
  128.   (let ((d (GetNewDialog 131 0 -1))
  129.         (type (make-string (c:sizeof 'short) 0))
  130.         (h (make-string (c:sizeof 'Handle) 0))
  131.         (box (make-rect))
  132.         chandles item-str item-int)
  133.     (unwind-protect
  134.         (progn
  135.           (setq item-str (NewPtr 2))
  136.           (if (zerop (MemError))
  137.               (progn
  138.                 (modifiers:extract-chandles)
  139.                 (modifiers:revert)
  140.                 (ShowWindow d)
  141.                 (InitCursor)
  142.                 (encode-internal item-str 0 'short 0)
  143.                 (while (progn (setq item-int (extract-internal item-str 0 'short))
  144.                               (and (not (= item-int modifiers:ok-button))
  145.                                    (not (= item-int modifiers:cancel-button))))
  146.                   (cond
  147.                    ((= item-int modifiers:revert-button)
  148.                     (modifiers:revert))
  149.                    ((= item-int modifiers:default-button)
  150.                     (modifiers:set-defaults))
  151.                    ((= item-int modifiers:simple-meta-button)
  152.                     (modifiers:set-simple-meta))
  153.                    ((>= item-int modifiers:first-check-box)
  154.                     (GetDItem d item-int type h box)
  155.                     (let ((chandle (extract-internal h 0 'unsigned-long)))
  156.                       (SetCtlValue chandle (if (zerop (GetCtlValue chandle)) 1 0)))))
  157.                   
  158.                   (ModalDialog (function modifiers:filter) item-str))
  159.                 
  160.                 (if (= item-int modifiers:ok-button)
  161.                     (modifiers:set-vector-from-dialog)))))
  162.       (DisposeDialog d))))
  163.  
  164. (defun modifiers:filter (d e i)
  165.   (let ((what (c:slotref 'EventRecord e 'what)))
  166.     (cond
  167.      ((= what updateEvt)
  168.       (SetPort d)
  169.       (TextFont geneva)
  170.       (TextSize 9)
  171.       0)
  172.      ((= what keyDown)
  173.       (let ((c (logand (c:slotref 'EventRecord e 'message) charCodeMask))
  174.             (modifiers (c:slotref 'EventRecord e 'modifiers)))
  175.         (if (or (= c (string-to-char "\r")) (= c 3))
  176.             (progn
  177.               (encode-internal i 0 'short stacksize-ok-button)
  178.               (blink d stacksize-ok-button)
  179.               1)
  180.           (if (and (= c (string-to-char ".")) (not (zerop (logand modifiers cmdKey))))
  181.               (progn
  182.                 (encode-internal i 0 'short stacksize-cancel-button)
  183.                 (blink d stacksize-cancel-button)
  184.                 1)
  185.             0))))
  186.      (t
  187.       0))))
  188.